２９−３６．シ−ト上の指定したセルをgifで保存
○●● ホ−ムペ−ジを出していると説明用に、シ−トの特定セルを切り取り図形(gif) で保存したいケ−スがよくあります。簡単に変換する方法がないか色々考え ようやく出来たのが下記マクロです。（本人評価→スゴク便利）

マクロの説明：
[1]開いているブックと同じフォルダ−へ保存します。(新規作成のブックは一度保存すること）
[2]変換したいセルの場所はマウスで範囲を指定（InputBoxメソッドのType:=8使用）
[3]指定した範囲を図でコピ−（Format:=xlBitmapがピクチャ−より綺麗だった）
[4]図の大きさを取得し、それより少し大きいChart枠を作成[3]を貼り付け
[5]Exportメソッドでgifファイルとして保存（ファイル名は"Mygif.gif"としてある）
[6]上記で仮作成した、図とチャ−トを削除
 

Sub 例2936()
Dim grf As Chart
Dim scel As Range

'保存先パス
phn = ActiveWorkbook.Path
     If phn = "" Then
         MsgBox "このブックと同じフォルダ−へGIFを保存します" & Chr(10) _
        & "パス未定の為ブックを1度保存してから実行して下さい"
        Exit Sub
     End If

'コピ−個所指定
    msg = "GIFで保存するセル範囲を指定して下さい。" & Chr(10) _
    & "(セル範囲をシ−トから指定して下さい)"
    On Error Resume Next
    Application.DisplayAlerts = False
    Set scel = Application.InputBox(msg, "セル指定", Type:=8)
    Application.DisplayAlerts = True
    If TypeName(scel) = "Nothing" Then
        MsgBox "セル範囲をシ−トから指定して下さい" 
        Exit Sub
    End If
    On Error GoTo 0
    scel.Select
'画像コピ−
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  ActiveSheet.Paste
  ActiveSheet.Pictures.Select
  pnam2 = Selection.Name
        
  ActiveSheet.Shapes(pnam2).Select
    hei = Selection.ShapeRange.Height
    wid = Selection.ShapeRange.Width
'チャ−ト枠作成
  Set grf = ActiveSheet.ChartObjects.Add(0, 0, wid + 8, hei + 8).Chart
  grf.Paste

'gif保存
   grf.Export phn & "\" & "Mygif.gif"
'仮作成の図形削除
   grf.Parent.Delete
   ActiveSheet.Shapes(pnam2).Select
   Selection.Delete
     
  Range("A1").Select
End Sub
参考２９-２　マクロで罫線を付ける場合の注意点
○●● マクロで罫線を付ける場合Excel95では自動記録したマクロをそのまま使用して 問題なかったが、Excel95/2000では線の指定方法が変わっており問題あり。 具体的には下記左図でマクロを作成した場合、右図のように項目欄のみで デ−タが無い場合エラ−になる。対策としては「Sub 参2922()」のように 行間の横線はデ−タが無い場合パスさせる。

注意：「書式設定ツ−ルバ−」の「罫線アイコン」で1行のみを自動記録した場合、 行間の横線が無いのに記録させておりそのマクロを実行するとエラ−になります。 （「編集」「セル」「罫線」から記録する場合は行間の横線が指定できないので問題なし） 


Sub 参2921()
'最終セル
      ActiveCell.SpecialCells(xlLastCell).Select
      endr = ActiveCell.Row
      endc = ActiveCell.Column
'罫線
 Range(Cells(2, 1), Cells(endr, endc)).Select
    Selection.Borders(xlEdgeLeft).Weight = xlThin
    Selection.Borders(xlEdgeTop).Weight = xlThin
    Selection.Borders(xlEdgeBottom).Weight = xlThin
    Selection.Borders(xlEdgeRight).Weight = xlThin
    Selection.Borders(xlInsideVertical).Weight = xlThin
    Selection.Borders(xlInsideHorizontal).Weight = xlThin
    Range("A2").Select
End Sub

Sub 参2922()
'罫線
Range(Cells(2, 1), Cells(endr, endc)).Select
    Selection.Borders(xlEdgeLeft).Weight = xlThin
    Selection.Borders(xlEdgeTop).Weight = xlThin
    Selection.Borders(xlEdgeBottom).Weight = xlThin
    Selection.Borders(xlEdgeRight).Weight = xlThin
    Selection.Borders(xlInsideVertical).Weight = xlThin
 If endr <> 2 Then
    Selection.Borders(xlInsideHorizontal).Weight = xlThin
 End If
    Range("A2").Select
End Sub

２９−３７．ワ−ドア−トによる文字作成
○●● これは自動記録でマクロを作成でき特にノウハウ的なものは無いが、自動記録は 「ワ−ドア−ト名」が固定なので２度目を走らすとエラ−になるので、下記のように 名前を取得しその名前に対して実行すれば問題は起きない。 

Sub Macro1()
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect30, "ＶＢＡ便利帳", "ＭＳ Ｐゴシック", 36#, _
    msoFalse, msoFalse, 346.5, 112.5).Select
    Selection.ShapeRange.TextEffect.ToggleVerticalText
    Selection.ShapeRange.TextEffect.PresetShape = msoTextEffectShapeWave1
    Selection.ShapeRange.IncrementRotation -4.15
    pnam2 = Selection.Name
    Range("C5").Select
    ActiveSheet.Shapes(pnam2).Select
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 11
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.ShapeRange.Fill.OneColorGradient msoGradientFromCenter, 1, 0.38
    Application.CommandBars("WordArt").Visible = False
End Sub

２９−３８．シ−ト上の指定した図形をgifで保存
○●● 29-36項とあまり変わらないが、こちらは枠線を消しました。Excelのワ−ドア−ト を使用してかなりの図形文字が書けるが、その文字に背景画を付けると下記イメ−ジ図 も簡単に作成できる。それをgifに落とすのがかなり面倒だったが下記マクロで 簡単に出来ます。（色々貼り付けた絵はグル−プ化後変換すること） (下記図は別アプリケ−ションで透過してあります）
 

Sub 例2938()
Dim grf As Chart

'保存先パス
phn = ActiveWorkbook.Path
     If phn = "" Then
         MsgBox "このブックと同じフォルダ−へGIFを保存します" & Chr(10) _
        & "パス未定の為ブックを1度保存してから実行して下さい"
        Exit Sub
     End If

'コピ−個所指定
    On Error Resume Next
    pnam2 = Selection.Name
    If Err = 1004 Then
       MsgBox "図を選んでから実行して下さい"
       On Error GoTo 0
       Exit Sub
    End If
       On Error GoTo 0
'画像コピ−
    ActiveSheet.Shapes(pnam2).Select
    hei = Selection.ShapeRange.Height
    wid = Selection.ShapeRange.Width
    Selection.Copy
'チャ−ト枠作成
  Set grf = ActiveSheet.ChartObjects.Add(0, 0, wid + 8, hei + 8).Chart
  grf.Paste
  ggg1 = grf.Name
  ggg2 = Mid(ggg1, InStr(1, ggg1, "グ", 1))
    
'枠線なし
    ActiveSheet.ChartObjects(ggg2).Activate
    ActiveChart.ChartArea.Select
    Selection.Border.LineStyle = 0
'gif保存
   grf.Export phn & "\" & "Mygif.gif"
'仮作成の図形削除
   grf.Parent.Delete
   Range("A1").Select
End Sub

２９−３９．日本語文字内の空白削除
●●● 英訳対照表を使用し日本語を英訳していますが、日本語に"カ セット" 等、間に ブランクが入る(誤ってブランクが入っている)日本語は変換されない。このブランク を削除する方法を教えて下さい。と言う質問への返事。 

Sub 例2939()
Cells(1, 1) = "Aaaaa Bbbbbb ア ルミCcccc Ddddカ セット eeムー ンＲ"
   dat = Cells(1, 1)
   ja = 1: jb = 0: daa = ""
   Do
   da1 = InStr(ja, dat, " ")
   If da1 > 0 Then
        data = Mid(dat, da1 - 1, 1)
        If Hex(Asc(data)) > "8100" Then
            jb = 1
            daa = Left(dat, da1 - 1)
            dab = Mid(dat, da1 + 1)
            dat = daa & dab
            ja = da1
        Else
            ja = da1 + 1
        End If
    Else
        If jb = 1 Then
            Exit Do
        End If
    End If
  Loop Until da1 = 0
    Cells(3, 1) = dat
End Sub
結果：Aaaaa Bbbbbb アルミCcccc DdddカセットeeムーンＲ
本例はブランクを全てチェックし、そのブランクが日本語の後ろの場合は 削除しました。日本語の判定として一応アスキ−コ−ドの"8100"以上としましたが このマクロで問題がある場合は再度メ−ルを下さい。（なお上記例のように "セット ee"が"セットee"のように全ての日本文字の後ろが詰まる欠点があります）。

２９−４０．セル内デ−タの空白削除
●●● 前記(29-39)のように文字内の空白を削除する場合は、少し面倒だが、もし セルデ−タ全部の空白削除を削除するのであれば下記例のように簡単に出来る。 （本例は日本語の全角空白も削除した例） 

Sub 例2940()
 Cells(1, 1) = "Aaaaa Bbbbbb ア　ルミCcccc Ddddカ セット eeムー ンＲ"
   Cells(1, 1).Select
   ActiveCell.Replace " ", ""
   ActiveCell.Replace "　", ""
End Sub
結果：AaaaaBbbbbbアルミCccccDdddカセットeeムーンＲ
参考２９-３　ASCコ−ド番号の取得
●●●前項(29-39)でアスキ−コ−ドが知りたかったので 下記の簡単なマクロを作成した。 

Sub 参293()
     msg = "ASCコ−ドを取得する文字を入力してください。"
    moz = Application.InputBox(msg, "文字入力", "", Type:=2)
    If moz = "" Then
       Exit Sub
    End If
    msg1 = "文字｢" & moz & "」のASCコ−ドは" & Chr$(10) & Chr$(10) _
         & "  →→  &H" & Hex(Asc(moz))
    MsgBox msg1
End Sub
参考２９-４　ASCコ−ド番号から文字を取得
●●●前項(参考２９-３)の逆も今後使うことがあると思い ついでに作成。 

Sub 参294()
    msg = "文字を取得するASCコ−ドを入力してください。" & Chr$(10) _
          & "(入力したコ−ド番号は16進数として解釈）"
    moz1 = Application.InputBox(msg, "文字入力", "", Type:=2)
    If moz1 = "" Then
       Exit Sub
    End If
    moz = "&H" & moz1
    If IsNumeric(moz) = False Then
        MsgBox "入力した文字は16進数になりません"
        Exit Sub
    End If
    
    msg1 = "ASCコ−ド「" & moz & "」の文字は" & Chr$(10) & Chr$(10) _
         & "   →→→  " & Chr(moz)
    MsgBox msg1
End Sub

２９−４１．フォルダ−を作成しその中へ保存する
●●● シ−ト上の図形をGIFで保存するマクロを作成したが、GIFファイルを 多数作成した場合、1個のフォルダ−へ入れた方が後から扱い易いので フォルダ−を新規作成しそこに保存することにした。 

Sub 例2941()
'保存先パス
phn = ActiveWorkbook.Path
     If phn = "" Then
         MsgBox "このブックと同じフォルダ−へ保存します" & Chr(10) _
        & "パス未定の為ブックを1度保存してから実行して下さい"
        Exit Sub
     End If
'フォルダ−チェック
    If Dir(phn & "\MyGIF" & "\*") = "" Then
    On Error Resume Next
       MkDir phn & "\MyGIF"
    If Err = 75 Then
       RmDir phn & "\MyGIF"
       MkDir phn & "\MyGIF"
    End If
       On Error GoTo 0
End If
  phn = phn & "\MyGIF"
’-----保存マクロは省略（29-36・29-38参照）----
End Sub
ファルダ−の有無チェックでファイル指定"\*"が無いとエラ−になります。
なお、ファルダ−があっての中にファイルが無い場合のエラ−対策も必要。

２９−４２．画面サイズの拡大
●●● ツ−ルバ−を非表示にして画面を最大に表示する場合は、クラスモジュ−ルへ 下記マクロ記述で出来る。（なお、本例のようにブックを閉じた時元の状態 へ戻すマクロも入れておかないとツ−ルバ−は表示されません） 

'画面サイズ拡大
Private Sub Workbook_Open()
    If Application.DisplayFullScreen = False Then
        Application.DisplayFullScreen = True
    End If
End Sub

'画面サイズ戻す
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
    Application.DisplayFullScreen = False
End Sub

２９−４３．シ−トの一部を拡大表示(プロジェクタ−使用時便利)
○●●
[1]下図の「→」ボタンへマクロ「Sub 拡大()」を登録
[2]下図の「←」ボタンへマクロ「Sub 縮小()」を登録
[3]下図の「削除」ボタンへマクロ「Sub 削除()」を登録
[4]最初に「→」ボタン押すとインプットボックスが表示されるので拡大範囲を指定
[5]２回目からは「→」を押すごとに拡大表示（倍率は定数、kw1・kh1で指定）
[6]「←」を押すごとに縮小表示（倍率は定数、kw2・kh2で指定）
[7]注意：拡大したセル範囲に色が付きます(色が無い場合下の文字と重複表示)。
 

Const kw1 As Single = 1.2   '図形の拡大（横）
Const kh1 As Single = 1.3   '図形の拡大（縦）
Const kw2 As Single = 0.8   '図形の縮小（横）
Const kh2 As Single = 0.7   '図形の縮小（縦）
Dim kw As Single
Dim kh As Single

Dim km As Integer        '拡大
Dim pnam2 As String    '図形名
Dim scel As Object
 Sub 拡大()
 If ActiveSheet.Pictures.Count = 0 Then
    km = 0
 End If
     kw = kw1
     kh = kh1
     セル指定
 End Sub
Sub 縮小()
     kw = kw2
     kh = kh2
     セル指定
End Sub

Sub セル指定()
If km = 0 Then
'コピ−個所指定
    msg = "拡大したいセル範囲を指定して下さい。" & Chr(10) _
                & "(セル範囲をシ−トから指定して下さい)"
    On Error Resume Next
        Application.DisplayAlerts = False
        Set scel = Application.InputBox(msg, "セル指定", Type:=8)
        Application.DisplayAlerts = True
    If TypeName(scel) = "Nothing" Then
        MsgBox "セル範囲をシ−トから指定して下さい"
        Exit Sub
    End If
    On Error GoTo 0
    scel.Select
    Selection.Interior.ColorIndex = 35
'画像コピ−
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Range("B2").Select
    ActiveSheet.Paste
    
    shc = ActiveSheet.Pictures.Count
    ActiveSheet.Pictures(shc).Select
    pnam2 = Selection.Name
  
  ActiveSheet.Shapes(pnam2).Select
    hei = Selection.ShapeRange.Height
    wid = Selection.ShapeRange.Width
End If
   表示
End Sub

Sub 表示()
'拡大表示
km = 1
ActiveSheet.Shapes(pnam2).Select
 Selection.ShapeRange.ScaleWidth kw, msoFalse, msoScaleFromTopLeft
 Selection.ShapeRange.ScaleHeight kh, msoFalse, msoScaleFromTopLeft
 DoEvents
Range("A1").Select
End Sub
 
Sub 削除()
km = 0
shc = ActiveSheet.Pictures.Count
If shc > 0 Then

        shc = ActiveSheet.Pictures.Count
       ActiveSheet.Pictures(shc).Select
       pnam2 = Selection.Name
        ActiveSheet.Shapes(pnam2).Select
        Selection.Delete
End If
End Sub

２９−４４．キ−に実行マクロを設定
○●● 前項（29-43）ではA列のコマンドボタンでマクロを実行しましたが、 実際はA列が使用等ボタンの貼る位置は固定出来ません。したがって 下記のようにキ−に実行マクロを設定方法が実用的。

　・「Ctrl]+「↑キ−」で、29-43項図の「→」ボタンと同じ機能
　・「Ctrl]+「↓キ−」で、29-43項図の「←」ボタンと同じ機能
　・「Ctrl]+「Deleteキ−」で、29-43項図の「削除」ボタンと同じ機能
 

Private Sub Workbook_Open()
   Application.OnKey "^{up}", "拡大"
   Application.OnKey "^{down}", "縮小"
   Application.OnKey "^{del}", "削除"
End Sub

２９−４５．ファンクションキ−にマクロを設定
○●● 前項（29-43）ではA列のコマンドボタンでマクロを実行しましたが、 実際はA列が使用等ボタンの貼る位置は固定出来ません。したがって 下記のようにファンクションキ−にマクロを登録す方法が実用的。

　・「F10キ−」で、29-43項図の「→」ボタンと同じ機能
　・「F11キ−」で、29-43項図の「←」ボタンと同じ機能
　・「F12キ−」で、29-43項図の「削除」ボタンと同じ機能
 

Private Sub Workbook_Open()
   Application.OnKey "{F10}", "拡大"
   Application.OnKey "{F11}", "縮小"
   Application.OnKey "{F12}", "削除"
End Sub

２９−４６．セルの色を取得し後から元に戻す
○●● 29-43項で拡大表示の関係でセルに色を付けた(色が無い場合下の文字 を重複表示）、下記マクロで仮に付けた色を消し元に戻せます。 

Dim col(100)
Dim scel As Object
 
Sub セル指定()
'コピ−個所指定
    msg = "セル範囲を指定して下さい。"
    On Error Resume Next
        Application.DisplayAlerts = False
        Set scel = Application.InputBox(msg, "セル指定", Type:=8)
        Application.DisplayAlerts = True
    If TypeName(scel) = "Nothing" Then
        MsgBox "セル範囲をシ−トから指定して下さい"
        Exit Sub
    End If
    On Error GoTo 0
    scel.Select
    色1
Range("A1").Select
End Sub

Sub 戻す()
scel.Select
色2
Range("A1").Select
End Sub
Sub 色1()
i = 1
For Each sel In Selection
        If sel.Interior.ColorIndex = xlNone Then
           col(i) = xlNone
           sel.Interior.ColorIndex = 35
        Else
           col(i) = sel.Interior.ColorIndex
        End If
        i = i + 1
Next sel
End Sub
Sub 色2()
i = 1
For Each sel In Selection
    sel.Interior.ColorIndex = col(i)
        i = i + 1
Next sel
End Sub
参考２９-５　マクロを有効にするメッセ−ジの非表示化
○○● 下記メッセ−ジを非表示にする方法を教えて下さい。との質問が あったので返事を掲載します。



[ツ−ル]→[マクロ]→[セキュリティ]→[セキュリティレベル(低)]にマ−ク

２９−４７．特定のセルへ日本語入力
○●● エクセル９７を使用中ですが，決められたセルにきたら日本語入力がＯＮ／ＯＦＦ することは可能なのでしょうか？又，出来るとしたらどうすれば？ 簡単な方法が有れば教えて下さい。と言う質問への返事。

・各シ−トのクラスモジュ−ルへ下記サンプルを貼り付け使用。
・アイコンで指定した「ひらがな」「かたかな」等になります。
・アイコンでIMEをONにした場合どのセルでもONのまま。OFFにしてから下記マクロを使用
 

(1)　セル１個の場合
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
  If Target.Address = Cells(2, 2) Then
     Selection.Validation.IMEMode = xlIMEModeOn
  End If
End Sub

(2)列を指定した場合
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim retu As Variant
Set retu = Application.Intersect(Target, Range(Columns(2), Columns(3)))
  If retu Is Nothing Then
      Exit Sub
  Else
    With Selection.Validation
        .Delete
        .Add Type:=xlvalidatelnputonly
        .IMEMode = xlIMEModeOn
    End With
  End If
End Sub

２９−４８．アドインの作成と組み込み
○●● 私の出しているソフトKIwebをよく使用するので、アドイン登録して 常に使用できるようにしたいが方法が判らないので教えて下さい と言うメ−ルへの返事。

[1]KIwebを開く

[2]メニュ−の「ウインドウ」「再表示」で「KIweb.xls」を選択 (表示にしないと「名前を付けて保存」が出来ない為)

[3]メニュ−の「ファイル」「名前を付けて保存」ダイアログが表示されたら 「ファイルの種類」で（Microsoft　Excel　アドイン）を指定して保存する。 このとき、フォルダ−はAddinsになっているはずですが、そこへ保存する。 (Addinsの場所は：Windows\Application Data\MicrosofAddins)

[4]メニュ−の「ツ−ル」「アドイン」下図のダイアログが表示されたら、 Kiwebの所へチェックマ−クを付ける。



[5]次にExcelを起動した時からKIwebは開いています。
参考２９-６　マクロの実行時間を測定
"Timer"関数は午前０時からの経過秒数をSingle型の値を返す。 下記のようにマクロの実行時間を測定に使用することも出来ます。 

timck = Timer
For i = 1 To cen1
    Range(Cells(4, 17), Cells(endr, 17)) _
    .Replace What:=yaku(0, i), Replacement:=yaku(1, i), LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=True, MatchByte:=True
Next
MsgBox "マクロ処理時間(秒)⇒　" & Timer - timck

※　上記の変数cen1・endr・配列yaku(*, *)は事前に代入してあります。

２９−４９．文字の入替を高速で行なうには
○●● 上記の参考２９-６を実行した場合、デ−タが多くなった場合文字の入替 にかなりの時間が掛かります。1年以上前に日本語デ−タの英訳ソフトを 依頼されこの方法でマクロを組みましたが、実行時間が1時間ほど掛かるので もっと短縮できないかとの検討依頼があった。下記が検討結果であるが 約７倍早くなった。（大文字・小文字及び、半角・全角を区別しないて 文字の入替を行なう場合と、区別する場合でこんなにに差があると思って いなかったが今回1つ勉強になりました）
  True：大文字小文字を区別、False：区別しない True：半角全角を区別、False：区別しない 実行秒
1 MatchCase:=False MatchByte:=False 62.83
2 MatchCase:=True MatchByte:=False 62.66
3 MatchCase:=False MatchByte:=True 17.95
4 MatchCaseの記述省略 MatchByteの記述省略 18.01
5 MatchCase:=True MatchByte:=True 9.01
 
6
 
 
 
 Dim Myrang As Range
Set Myrang = Range(Cells(4, 17), Cells(endr, 17))
Myrang _
.Replace What:=yaku(0, i), Replacement:=yaku(1, i), LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=True, MatchByte:=True
  
8.83
 
 
 

※ 6項は変換対象のセル範囲をRangeのオブジェクトを宣言しSetで変数に入れたケ−ス。
※　変換対象のデ−タにより時間が変わりますが上記時間測定したデ−タは 全角の日本語が入っています。
※　結論：
もしデ−タが混在している場合は事前に統一し、文字の入替は、 大文字小文字及び、半角全角は区別して(True)実施した方がよい。
なお、セル範囲を変数に入れるケ−スは参照設定するだけであり高速には ほとんど効果がない。

２９− ５０．セルデ−タを全角又は半角文字に統一
○●● 半角・全角、小文字・大文字を区別して文字の検索や入替を行う場合は 事前にどちらかに統一してないとキ−ワ−ドと対象文字が一致しません。 下記の方法で簡単に統一できます。 

Sub 例2950()
'最終セル
      ActiveCell.SpecialCells(xlLastCell).Select
      endr = ActiveCell.Row
'
  For j = 4 To endr
     Cells(j, 2) = StrConv(Cells(j, 2), 8)
     Cells(j, 17) = StrConv(Cells(j, 17), 4)
  Next
End Sub
上記は、２列デ−タを半角に１７列デ−タを全角に統一した例。

(29-1〜29-20) (29-21〜29-35) (29-36〜29-50) (29-51〜29-61) (29-62〜29-73) (29-74〜 　　)

目次へ戻る

PC用眼鏡【管理人も使ってますがマジで疲れません】 解約手数料０円【あしたでんき】 Yahoo 楽天 NTT-X Store

無料ホームページ 無料のクレジットカード 海外格安航空券 ふるさと納税 海外旅行保険が無料！ 海外ホテル